The Original Shareware 1.1/The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso/38/sgn_bans.zip/PRINTPAK.PAS

Pascal/Delphi Source File | 1985-12-17 | 22KB | 632 lines

{ PrintPak.Pas }
{ Print very high-res graphics on EPSON FX-80/RX-80 }

{ by  Bryan B. Smith }
{ Based on ideas from Byte, Nov. 1985, pp. 219-232

{ Storage order in bitmap arrays has been reversed so that bytes are }
{ stored in the sequence in which they are to be printed.  This permits }
{ high-speed graphics printing by the procedure PrintBlock. }
{ Effective size of the arrays has been increased beyond the max. permitted }
{ 64K by use of an array of pointers to 64K arrays. }

{ START GLOBAL DECLARATIONS ... }

{$V-}               { prohibits compiler checks of string size }

const
  across = 1599 ;
  down = 39 ; { change next line also }
  DownPlusOne = 40 ;
  LastLineDown = 1279 ; { (39+1)*2*16 - 1 }
  hsteps = 9.4504 ; { horizontal steps/mm, fount by experiment }
  vsteps = 5.9167 ; { vertical   steps/mm, found by experiment }
  leftmarg : integer = 7 ; { extra left-marg. space needed to centre }
  NumberOfFonts = 4 ;

type
  data_type = array[0..down,0..across] of byte ;
  mask_array = array[0..7] of byte ;
  word_mask_array = array[0..15] of integer ;
  Font1Descrip = array[0..255,0..7] of byte ;
  Font2Descrip = array[0..255,0..13] of byte ;
  Font3Descrip = array[0..255,0..13] of integer ;
  Font4Descrip = array[0..255,0..27] of integer ;
  utilitystr = string[80] ;

const
  M : mask_array = ($80,$40,$20,$10,$08,$04,$02,$01) ; { +ve mask }
  R : mask_array = ($7F,$BF,$DF,$EF,$F7,$FB,$FD,$FE) ; { "not" M }
  WM : word_mask_array =
           ($8000,$4000,$2000,$1000,$0800,$0400,$0200,$0100,
            $0080,$0040,$0020,$0010,$0008,$0004,$0002,$0001) ;

Var
  EvenMap, OddMap : array[0..1] of ^data_type ;
  lowest : integer ;
  halfwid, halfht : integer ;
  Font1 : Font1Descrip ;
  Font2 : Font2Descrip ;
  Font3 : Font3Descrip ;
  Font4 : Font4Descrip ;
  Font1File : file of Font1Descrip ;
  Font2File : file of Font2Descrip ;
  Font3File : file of Font3Descrip ;
  Font4File : file of Font4Descrip ;
  WantScreen, WantPrint, FirstCharOnly, CheckTextOnly : boolean ;
  Landscape, grid : boolean ;
  WantFont : array[1..NumberOfFonts] of boolean ;

{ END of global declarations }

Procedure DrawGrid ; { Draws a grid - of course ! }

Var
  j, k, x,y,xstart,xend,xinc,ystart,yend,yinc : integer ;

begin
  plot(0,0,1) ;
  plot(0,199,1) ;
  for j := 1 to 12 do
  begin
    x := j * 50 ;
    plot(x,0,1) ;
    plot(x,199,1) ;
    for k := 1 to 16 do
    begin
      if landscape
        then y := trunc(k*12.5) - 1
        else y := trunc((k-1)*12.5) ;
      plot(x,y,1) ;
      plot(0,y,1) ;     { lots of repeated points here ... }
      plot(639,y,1) ;   {      but no detectable time lost }
    end ; { k }
  end ; { j }
end ;  { DrawGrid }

Procedure Init_PrintPak ;

{ Performs the initialization chores }

Var
  i, j : integer ;
  prefix : string[20] ;
  fontname : string[30] ;


begin
  if WantPrint then { Don't allocate bitmap space if not required. }
                    { That way, can debug on screen on machine with }
                    { small memory. }
  begin
    for j := 0 to 1 do
    begin
      new(EvenMap[j]) ;  { set aside memory space for arrays }
      new( OddMap[j]) ;
      { fillchar is infinitely faster than code in BYTE - BBS ... }
      fillchar(EvenMap[j]^[0,0], (across+1)*(down+1), 0 ) ;
      fillchar( OddMap[j]^[0,0], (across+1)*(down+1), 0 ) ;
    end ; { for }
  end ; { if WantPrint }

  lowest  := (down+1)*8*2*2 - 1 ;  { line number of lowest printer line }
  halfwid := (across+1) div 2 ;   { # cols in left half of printout }
  halfht  := (lowest+1) div 2 ;   { # lines in top half of printout }

  SearchEnvironment('SSMF',Prefix) ; { Gets disk prefix or null string }

  If WantFont[1] then
  begin
    FontName := Prefix + 'FONT1.FNT' ;
    Assign(Font1File,FontName) ;
    {$I-}
    reset(Font1File) ;
    {$I+}
    if IOresult <> 0 then
    begin
      writeln('Can not find font file ',FontName) ;
      halt ;
    end ;
    ClrScr ;
    Writeln('Loading Font 1') ;
    read(Font1File,Font1) ;
  end ; { font 1 }

  If WantFont[2] then
  begin
    FontName := Prefix + 'FONT2.FNT' ;
    Assign(Font2File,FontName) ;
    {$I-}
    reset(Font2File) ;
    {$I+}
    if IOresult <> 0 then
    begin
      writeln('Can not find font file ',FontName) ;
      halt ;
    end ;
    Writeln('Loading Font 2') ;
    read(Font2File,Font2) ;
  end ; { font 2 }

  If WantFont[3] then
  begin
    FontName := Prefix + 'FONT3.FNT' ;
    Assign(Font3File,FontName) ;
    {$I-}
    reset(Font3File) ;
    {$I+}
    if IOresult <> 0 then
    begin
      writeln('Can not find font file ',FontName) ;
      halt ;
    end ;
    Writeln('Loading Font 3') ;
    read(Font3File,Font3) ;
  end ; { font 3 }

  if WantFont[4] then
  begin
    FontName := Prefix + 'FONT4.FNT' ;
    Assign(Font4File,FontName) ;
    {$I-}
    reset(Font4File) ;
    {$I+}
    if IOresult <> 0 then
    begin
      writeln('Can not find font file ',FontName) ;
      halt ;
    end ;
    Writeln('Loading Font 4') ;
    read(Font4File,Font4) ;
  end ; { font 4 }

end ; { Init_PrintPak }

Procedure PrintBlock(var a ; SizeInBytes: integer ) ;
{
This procedure was needed because the print method used in Byte,
i.e. 1600 calls to "write" per print line, had so much overhead
that the CPU could not keep up with the printer, and so the
printer moved in a series of prints and backups across each line.
In contrast, this assembler code has low enough overhead that the
printer runs continuously.

The procedure will print either bytes or chars.  The number of
bytes/chars printed is limited to MaxInt.  Note that "a" does not
have any type in the argument list, and that it must be declared
"var".  Having no type, it may not be used in the procedure,
except as an absolute address.

Note - providing LST with a 2K buffer, e.g.
  Var List : Text[$800] ;
  assign(List,'LST:') ;
  write(List,...
did NOT prevent the print-and-backup action of the printer.
}

Var
  aa : array[1..maxint] of byte absolute a ;
  aseg,aofs : integer ;

begin
  aseg := seg(aa) ; aofs := ofs(aa) ;
  inline(
      { Set up for the big print ... }
    $8B/$8E/SizeInBytes/   { MOV CX,SizeInBytes[BP] }
    $8B/$BE/Aofs/          { MOV DI,Aofs[BP] }
    $8E/$86/Aseg/          { MOV ES,Aseg[BP] }
      { Now Print it ... }
    $83/$F9/$00/           { AGAIN : CMP CX,0 }
    $74/$0B/               { JE  DONE }
    $26/$8A/$05/           { MOV AL,ES:[DI] }
    $32/$E4/               { XOR AH,AH }
    $CD/$17/               { INT 17H }
    $49/                   { DEC CX }
    $47/                   { INC DI }
    $EB/$F0/               { JMP AGAIN }
    $90                    { DONE: NOP}
  ) ;
end ;

Procedure Printout ;  { Output to Epson FX-type printer }

{ Prints out the 256KB (almost) bit map.  That's almost 2 million }
{ bits - or printhead wires.  Had to modify the original source a }
{ a lot so we did not waste printer time on empty right ends of   }
{ lines, and so that the CPU could keep up with the printer !     }

{ Remember that even though this uses quad-density graphics, the  }
{ Epson printer will not print 2 successive dots on the same row. }

Var
  n_lo, n_hi : byte ;
  i, j, last, part : integer ;
  ch : char ;

label EmptyLine ;

begin { Printout }
  write(LST,#27,'8') ; { single-sheet mode }
  { take any backlash out of printer linefeed mechanism ... }
  write(LST,chr(13)) ; { car. return }
  write(LST,chr(27),'3',chr(1)) ;  { set linefeed for 1/3 dot down }
  for j := 1 to 10 do write(LST,chr(10)) ;             { linefeeds }
{
  Since CPU is faster than printer, we will invest a little CPU time to
  avoid printing empty trailing portion of line.  BBS
}
  for part := 0 to 1 do  { for two halves of page }
  begin
    for j := 0 to 39 do  { for 40 lines in each half page }
    begin
      if keypressed then { check if user wants out }
      begin
        read(KBD,ch) ; { get rid of keystroke }
        write(LST,#12,#27,'2') ; { formfeed and reset linefeed to 1/6 " }
        write(LST,#27,'9') ;     { end single-sheet mode }
        TextMode(BW80) ;
        ClrScr ;
        halt ;
      end ; { if keypressed }
      last := across + 1 ;
      repeat
        last := last -1 ;
        if last = -1 then goto EmptyLine ;
      until (EvenMap[part]^[j,last] <> 0)
               or (OddMap[part]^[j,last] <> 0) ;

EmptyLine :
      if last > -1 then
      begin
        n_hi := (last+1) div 256 ; { part of number of graphic bytes coming }
        n_lo := (last+1) mod 256 ; { rest of number of graphic bytes coming }
        { spaces at start ofline act as filler, then enter }
        { graphics mode, giving number of graphic bytes coming }
        write(LST,'':LeftMarg,#27,'Z',chr(n_lo),chr(n_hi)) ;
        {"last" is index of the last non-zero byte: but first has index 0 ... }
        printblock(EvenMap[part]^[j,0],last+1) ;  { print even row }
        write(LST,#13) ;           { carriage return }
      end ;
      write(LST,#27,'3',#1) ;      { set linefeed for 1/3 dot down }
      write(LST,#10) ;             { linefeed }
      if last > -1 then
      begin
        write(LST,'':LeftMarg,#27,'Z',chr(n_lo),chr(n_hi)) ;
                                    { ... graphics mode again }
        printblock(OddMap[part]^[j,0],last+1) ;  { print odd row }
        write(LST,#13) ;            { carriage return }
      end ;
      write(LST,#27,'3',#22) ;      { set linefeed for 7 1/3 dot down }
      write(LST,#10) ;              { linefeed }
    end ; { for j }
  end ; { for part }
  writeln(LST,' ') ;
  write(LST,#12,#27,'2') ; { formfeed and reset linefeed to 1/6 " }
  write(LST,#27,'9') ; { end single-sheet mode }

end ; { Printout }

Procedure Pset1(xin,yin : integer ) ;

{ writes the dot at position (xin,yin) into memory arrays }

{ This modification of Pset that always uses colour = 1, and has the
{ (cleaned-up) Change procedure moved in-line to cut down on call
{ overheads.
{ An equivalent of Plot(x,y,1) has also been moved in-line for
{ speed-up purposes. }

Var
  I, line, height, part, x, y, old, Xforplot, Yforplot : integer ;
  odd,offset,t : integer ;

begin { Pset1 }
  if landscape
    then
    begin
      x := yin ; y := lastlinedown - xin ;
      { LastLineDown - y is same as xin, so ... }
      Xforplot := xin shr 1 ;   { xin div 2 }
      YforPlot := x shr 3 ;     { x div 8 }
    end
    else  { portrait mode }
    begin
      x := xin ; y := yin ;
      Xforplot := y shr 1 ;
      Yforplot := 200 - (x shr 3) ;
             { portrait mode sideways }
    end ; { if landscape else portrait }

  if WantScreen then
  begin

    { here, for speed, we will put the code to write point directly to
    { the graphics screen directly in line rather than take the overhead
    { of a procedure call.  This was not done in DrawGrid because speed
    { was not such a consideration there. }
    { This change cut draw time for an example from 27 down to 20 secs. }

    if (Yforplot and $0001) = 0 then offset := 0   { if even # line }
                                else offset := $2000 ;  { else odd # }
    offset := offset + 80*(Yforplot shr 1)
                     + Xforplot shr 3 ; { x divided by 8, y by 2 }
    t := mem[$B800:offset] or M[Xforplot and $0007] ; { remaind from div by 8 }
    mem[$B800:offset] := lo(t) ;
  end ;

  if WantPrint then
  begin
                                 { vertical position of pixel consists of a }
                                 { line # between 0 and down; and a height }
                                 { between 0 and 15, divided into }
                                 { even-odd groups }
    Line := Y shr 4 ; { maybe faster than := Y div 16 ; }
    height := (Y and $000F) shr 1 ; { same as := (Y mod 16) div 2 ; }
    if Line <= down then part := 0    { in first  set of arrays }
                    else part := 1 ;  { in second set of arrays }
    line := line mod (DownPlusOne) ; { line number within lower map, maybe }
    if y mod 2 = 0 then
    begin  { even line }
      Old := EvenMap[part]^[line,x] ;
      EvenMap[part]^[line,x] := lo(old or M[height]) ;
      { insert set bit in place }
    end
    else   { odd line }
    begin
      Old := OddMap[part]^[line,x] ;
      OddMap[part]^[line,x] := lo(old or M[height]) ;
    end ;
  end ; { want print }
end ; { Pset1 }

Procedure PutChar(var cha ;
                  var xloc : integer ;
                  yloc,FontNumber,DotCols,DotRows,Between : integer ) ;

{ Puts one character into screen and into printer bit-map. }

Var
  ch : byte absolute cha ; { allows printing of any type }
  tb : byte ;
  j,k,mm,n,ti,dck,drj : integer ;

begin
  case FontNumber of

    1 : begin
      for j := 0 to 7 do
        begin
        tb := font1[ord(ch),j] ;
        for k := 0 to 7 do
          if (tb and M[k]) <> 0 then
          begin                            { each dot is expanded }
            For mm := 0 to DotCols-1 do    { to DotCols columns }
              for n  := 0 to DotRows-1 do  { and DotRows rows }
                Pset1(xloc+DotCols*k+mm,yloc+DotRows*j+n) ;
        end ; { for k }
      end ; { for j }
      xloc := xloc + (8+Between)*DotCols ;
    end ; { 1 }

    2 : begin
      for j := 0 to 13 do
        begin
        tb := font2[ord(ch),j] ;
        for k := 0 to 7 do
          if (tb and M[k]) <> 0 then
          begin                            { each dot is expanded }
            For mm := 0 to DotCols-1 do    { to DotCols columns }
              for n  := 0 to DotRows-1 do  { and DotRows rows }
                Pset1(xloc+DotCols*k+mm,yloc+DotRows*j+n) ;
        end ; { for k }
      end ; { for j }
      xloc := xloc + (9+Between)*DotCols ;
    end ; { 2 }

    3 : begin
      drj := 0 ;                           { drj is DotRows * j }
      for j := 0 to 13 do
        begin
        ti := font3[ord(ch),j] ;
        dck := 0 ;                         { dck is DotCols * k }
        for k := 0 to 15 do
        begin
          if (ti and WM[k]) <> 0 then
          begin                            { each dot is expanded }
            For mm := 0 to DotCols-1 do    { to DotCols columns }
              for n  := 0 to DotRows-1 do  { and DotRows rows }
                Pset1(xloc+dck+mm,yloc+drj+n) ;
          end ; { if }
          dck := dck + DotCols ;
        end ; { k }
        drj := drj + DotRows ;
      end ; { for j }
      xloc := xloc + (18+Between)*DotCols ;
      { explanation - for fonts 3 & 4, Putstring passes a temporarily }
      { doubled copy of Between to PutChar }
    end ; { 3 }

    4 : begin
      drj := 0 ;                           { drj is DotRows * j }
      for j := 0 to 27 do
        begin
        ti := font4[ord(ch),j] ;
        dck := 0 ;                         { dck is DotCols * k }
        for k := 0 to 15 do
        begin
          if (ti and WM[k]) <> 0 then
          begin                            { each dot is expanded }
            For mm := 0 to DotCols-1 do    { to DotCols columns }
              for n  := 0 to DotRows-1 do  { and DotRows rows }
                Pset1(xloc+dck+mm,yloc+drj+n) ;
          end ; { if }
          dck := dck + DotCols ;
        end ; { k }
        drj := drj + DotRows ;
      end ; { for j }
      xloc := xloc + (18+Between)*DotCols ;
      { explanation - see 3 }
    end ; { 4 }

  end ; { of cases }
end ; { PutChar }

Procedure PutString(Strng : utilitystr ;
                    xl : integer ;
                    var yloc : integer ;
                    FontNumber,DotCols,DotRows,Between : integer ;
                    centre,PrePass : boolean ;
                    var OffPage : boolean) ;

{ Puts a whole string onto screen and into printer bit map. }

{ Between is number of extra spaces between chars. }
{ if centre is true, the line is centred, and xl is ignored. }
{ on return, yloc is increased by twice the line height to provide }
{ auto line spacing for next line. }
{ if PrePass is true, will not print to screen or printer, but }
{ merely verify string fits on screen. }

Var
  j, xloc, xsize, ysize, LowestLine, YOffset, emptyx : integer ;
  temp, ti, lenstr : integer ;
  pct : real ;
  ch : char ;
  fault : boolean ;

const
  ln : string[6] = 'Line *' ;
  isoff : string[19] = '* is off page at ' ;
begin
  case FontNumber of
    1 : begin
          xsize  := 8 ;     { 8 columns per char., all bitmapped }
          ysize  := 8 ;     { 8 rows in bitmap }
          LowestLine := 7 ; { bottom of 'H' is line 7 of char. bitmap }
          emptyx := 0 ;      { all 8 cols mapped }
        end ; { 1 }
    2 : begin
          xsize  := 9 ;  { use 9 columns/char., 8 bitmapped + 1 blank }
          ysize  := 14 ; { 14 rows in bitmap }
          LowestLine := 11 ;
          emptyx := 1 ;   { 1 empty col in xsize }
        end ; { 2 }
    3 : begin
          xsize := 18 ;  { like font 2, but twice as wide }
          ysize := 14 ;
          LowestLine := 11 ;
          Between := 2*Between ;  { this is only a temp copy of between }
          emptyx := 2     { 2 empty cols in xsize }
        end ; { 3 }
    4 : begin
          xsize := 18 ;
          ysize := 28 ;  { like font 3, but twice as high }
          LowestLine := 22 ;
          Between := 2*Between ;  { only a temp. copy of Between }
          emptyx := 2 ;
        end ; { 4 }
  end ; { case }
  xsize  := (xsize + Between) * DotCols ;
  emptyx := emptyx * DotCols ;
  ysize  := ysize * DotRows ;
         { xloc will be altered by PutChar ...}
         { so make an alterable copy }
         { if centre is true, then the x-location xl is ignored }

  { allow for indexing by bottom print line of character like H or M }
  { this should make it much easier to get 2 sizes of type on same line }
  { Add 1 to allow user's y scale to start at 1, programs to start at 0 }
  { i.e. YOffset := LowestLine*DotRows - 1 + 1 }
  yoffset := LowestLine*DotRows ;
  if centre
       then
       if landscape
         then xloc := (LastLineDown - (length(Strng)*(xsize)
                          - Between*DotCols { don't count 1 space }
                          - emptyx))        { don't count non-print col }
                            div 2
         else xloc := (across - (length(Strng)*(xsize)
                          - Between*DotCols
                          - emptyx)) div 2
       else xloc := xl - 1 ; { -1 to allow user to use scale starting at 1 }
                             {    whereas program scale starts at 0 }

  { because PutChar indexes by TOP ROW of char, make temp. change in yloc }
  yloc := yloc - yoffset ;

  if PrePass
  then
  begin
    OffPage := false ;
    if yloc < 0 then
    begin
      temp := -yloc ;
      { 16. = 1600/100, 12.8 = 1280/100 }
      if landscape then pct := temp/16. else pct := temp/12.8 ;
      Writeln(ln,Strng,isoff,'top.') ;
      writeln('by ':8,temp,' rows, ',pct:7:3,' %') ;
      OffPage := true
    end ;
    if landscape
{
      then temp := yloc + (ysize-YOffset) - across
      else temp := yloc + (ysize-YOffset) - LastLineDown ;
}
      then temp := yloc + ysize - across
      else temp := yloc + ysize - LastLineDown ;
    fault := temp > 0 ;
    if fault then
    begin
      if landscape then pct := temp/16. else pct := temp/12.8 ;
      Writeln(ln,Strng,isoff,'bottom.') ;
      writeln('by ':8,temp,' rows, ',pct:7:3,' %') ;
      OffPage := true
    end ;
    if xloc < 0 then
    begin
      temp := -xloc ;
      if landscape then pct := temp/12.8 else pct := temp/16. ;
      Writeln(ln,Strng,isoff,'left.') ;
      writeln('by ':8,temp,' columns, ',pct:7:3,' %') ;
      OffPage := true
    end ;
    ti := xloc + length(strng)*xsize - 1 - Between*DotCols - emptyx ;
    if landscape
      then begin temp := ti - LastLineDown ; pct := temp/12.8 ; end
      else begin temp := ti - across ; pct := temp/16. ; end ;
    fault := temp > 0 ;
    if fault then
    begin
      Writeln(ln,Strng,isoff,'right.') ;
      writeln('by ':8,temp,' columns, ',pct:7:3,' %') ;
      OffPage := true
    end ;
  end
  else { *** NOT PRE-PASS, do the real thing *** }
  begin
    If not WantScreen then writeln('Working on "',Strng,'"') ;
    { maybe we do FirstCharOnly on a nul string ... lenstr = 0 }
    if FirstCharOnly and (length(Strng) > 1) then lenstr := 1
    else lenstr := length(Strng) ;
    for j := 1 to lenstr do
    begin
      if keypressed then { allow user to abort after each character }
      begin
        read(KBD,ch) ; { gobble up the character and ... }
        if (not WantScreen) then begin ClrScr ; halt ; end ;
        gotoxy(1,1) ;
        write('Press any letter to exit.  ') ;
        repeat until keypressed ; { ... wait while user examines screen }
        read(KBD,ch) ; { gobble character }
        TextMode(BW80) ; { reset screen }
        halt ;
      end ;
      ch := Strng[j] ;
      if FirstCharOnly and (ch = ' ') then ch := 'Z' ;
      PutChar(ch,xloc,yloc,FontNumber,DotCols,DotRows,Between) ;
    end ;
  end ; { else }

  yloc := yloc + yoffset ; { cancel temporary offset }
  yloc := yloc + 2*ysize ; { feed down by twice cell height }
end ; { PutString }